COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 -*-LISP-*-  History Recording System
C00003 00003
C00006 00004
C00007 00005
C00011 00006
C00014 00007
C00019 ENDMK
C⊗;
;;;; -*-LISP-*-  History Recording System

;;; (PUSH-HISTORY *HISTORY*)
;;; (POP-HISTORY *HISTORY*)
;;; (SET-HISTORY-TO-NEXT-REDUCTION *HISTORY*)
;;; (RECORD-EVALUATION-IN-HISTORY *HISTORY*)
;;; (SAVE-HISTORY!)
;;; (REINSTALL-HISTORY!)
;;; (RECLAIM-HISTORY!)
;;; (CHECK-AND-SAVE-HISTORY)
;;; (RESHAPE-AT-INTERRUPT)

(DEFVAR *HISTORY* NIL)
(DEFVAR *SAVED-HISTORY* NIL)
(DEFVAR *CURRENT-ENTRY* NIL)
(DEFVAR *CURRENT-BRANCH* NIL)

;;; include calling-continuation:

(include "sdebug.lsp")
(herald hist "")


;;;; History manipulation primitives

;;; History backbone

(defmacro history-branch (history)
  `(cxr 0 ,history))

(defmacro set-history-branch (history value)
  `(rplacx 0 ,history ,value))


(defmacro deeper-history (history)
  `(cxr 1 ,history))

(defmacro set-deeper-history (history value)
  `(rplacx 1 ,history ,value))


(defmacro shallower-history (history)
  `(cxr 2 ,history))

(defmacro set-shallower-history (history value)
  `(rplacx 2 ,history ,value))


(defmacro history-entry (history)
  `(cxr 3 ,history))

(defmacro set-history-entry (history value)
  `(rplacx 3 ,history ,value))


(defmacro history-mark (history)
  `(cxr 4 ,history))

(defmacro set-history-mark (history)
  `(rplacx 4 ,history t))

(defmacro clear-history-mark (history)
  `(rplacx 4 ,history nil))

;;; History entry ribs

(defmacro entry-expression (cell)
  `(cxr 0 ,cell))

(defmacro set-entry-expression (cell exp)
  `(rplacx 0 ,cell ,exp))


(defmacro next-entry (cell)
  `(cxr 1 ,cell))

(defmacro set-next-entry (cell value)
  `(rplacx 1 ,cell ,value))


(defmacro entry-mark (cell)
  `(cxr 2 ,cell))

(defmacro set-entry-mark (cell)
  `(rplacx 2 ,cell t))

(defmacro clear-entry-mark (cell)
  `(rplacx 2 ,cell nil))


(defmacro entry-environment (cell)
  `(cxr 3 ,cell))

(defmacro set-entry-environment (cell env)
  `(rplacx 3 ,cell ,env))

;;; History branch ribs

(defmacro branch-expression (cell)
  `(cxr 0 ,cell))

(defmacro set-branch-expression (cell exp)
  `(rplacx 0 ,cell ,exp))


(defmacro next-branch (cell)
  `(cxr 1 ,cell))

(defmacro set-next-branch (cell value)
  `(rplacx 1 ,cell ,value))


(defmacro branch-mark (cell)
  `(cxr 2 ,cell))

(defmacro set-branch-mark (cell)
  `(rplacx 2 ,cell t))

(defmacro clear-branch-mark (cell)
  `(rplacx 2 ,cell nil))


(defmacro branch-value (cell)
  `(cxr 3 ,cell))

(defmacro set-branch-value (cell value)
  `(rplacx 3 ,cell ,value))


;;;; Microcode history manipulation

(defmacro save-history! ()
  '(cond (*history*
	  (set-history-entry *history* *current-entry*)
	  (set-history-branch *history* *current-branch*)
	  (setq *saved-history* *history*)
	  (setq *history* nil))))

(defmacro reinstall-history! ()
  `(cond (*saved-history*
	  (setq *history* *saved-history*)
	  (setq *saved-history* nil)
	  (setq *current-entry* (history-entry *history*))
	  (setq *current-branch* (history-branch *history*)))))

(defmacro record-evaluation-in-history ()
  '(cond (*history*
	  (set-entry-expression *current-entry* (fetch exp))
	  (set-entry-environment *current-entry* (fetch env)))))

(defmacro set-history-to-next-reduction ()
  '(cond (*history*
	  (setq *current-entry* (next-entry *current-entry*))
	  (clear-entry-mark *current-entry*)
	  (setq *current-branch* (next-branch *current-branch*))
	  (set-branch-mark *current-branch*))))

(defmacro push-history ()
  '(cond (*history*
	  (set-branch-expression *current-branch* (fetch exp))
	  (set-history-entry *history* *current-entry*)
	  (set-history-branch *history* *current-branch*)
	  (setq *history* (deeper-history *history*))
	  (set-history-mark *history*)
	  (setq *current-branch* (history-branch *history*))
	  (setq *current-entry* (history-entry *history*))
	  (set-branch-mark *current-branch*)
	  (set-entry-mark *current-entry*))))

(defmacro pop-history ()
  '(cond (*history*
	  (clear-history-mark *history*)
	  (setq *history* (shallower-history *history*))
	  (setq *current-branch* (history-branch *history*))
	  (set-branch-value *current-branch* (fetch val))
	  (setq *current-branch* (next-branch *current-branch*))
	  (clear-branch-mark *current-branch*)
	  (setq *current-entry* (history-entry *history*)))))

(defmacro reclaim-history! ()
  '(cond (*history*
	  (setq *history* (deeper-history *history*))
	  (set-history-mark *history*)
	  (setq *current-branch* (history-branch *history*))
	  (setq *current-entry* (history-entry *history*)))))
	  

;;;; System interaction with history (debugging and initialization)

(defun merge-history (levels) ;Used in debugger
  (reinstall-history!)
  (cond ((= levels 0)
	 (push-history))
	(t (do ((i 1 (1+ i)))
	       ((= i levels) *noprint*)
	     (pop-history)))))

(defun find-caller (how-far-back current) ;Used in debugger
  (if (= how-far-back 0)
      current
      (find-caller (1- how-far-back) (calling-continuation current))))

(defun check-and-save-history ()  ;Used in bkpts and errors
  (progn
   (pop-history)
   (save-history!)))

(defmacro initialize (history in-exp in-env)
  `(cond (,history
	  (setq ,history (deeper-history ,history))
	  (set-history-mark ,history)
	  (let ((current-branch (history-branch ,history))
		(current-entry (history-entry ,history)))
	    (set-entry-mark current-entry)
	    (set-entry-expression current-entry (syntax ,in-exp))
	    (set-entry-environment current-entry ,in-env)
	    (set-branch-mark current-branch)))))

(defun reshape-at-interrupt (form)
  (initialize *saved-history*
	      form
	      (relative-lexical-access nil 'user-initial-environment)))
	  
(defun-import setup-history (depth entry-width branch-width)
  (setq *history* (create-history depth entry-width branch-width))
  (setq *current-branch* (history-branch *history*))
  (setq *current-entry* (history-entry *history*))
  (initialize *history* '(eval-with-history input env) (fetch env))
  (push-history))



;;;; History structure constructors

(defun create-history (depth entry-width branch-width)
  (if (and (> branch-width 0) (> entry-width 0) (> depth 0))
      (let ((spine (make-circle depth 8)))
	(link-backwards spine spine (deeper-history spine))	
	(do ((s (deeper-history spine) (deeper-history s)))
	    ((eq s spine)
	     (set-history-branch spine (make-circle branch-width 4))
	     (set-history-entry spine (make-circle entry-width 4))
	     spine)
	  (set-history-branch s (make-circle branch-width 4))
	  (set-history-entry s (make-circle entry-width 4))))))


(defun make-circle (len size)
  (let ((init (makhunk size))) ; extra variable to close list easily
    (do ((n 1 (1+ n))
	 (res init (let ((x (makhunk size))) (rplacx 1 x res) x)))
	((= len n) (rplacx 1 init res) res))))

(defun link-backwards (initial circle next)
  (cond ((eq next initial) (set-shallower-history initial circle)) ;Loop closed
	(t (set-shallower-history next circle)
	   (link-backwards initial next (deeper-history next)))))

(defun-import the-saved-history ()
  (extract-backbone *saved-history* *saved-history*))

(defun reverse-branch-list (rib)
  (let ((init (next-branch rib)))
    (reverse-branch-1 init
		      init
		      'wrap-around)))

(defun reverse-branch-1 (initial current list-so-far)
  (let ((next (next-branch current))
	(output (list (branch-expression current) (branch-value current))))
    (cond ((eq initial next)
	   (if (branch-mark current)
	       (cons output nil)
	       (cons output list-so-far)))
	  ((branch-mark current)
	   (reverse-branch-1 initial next (cons output nil)))
	  (t
	   (reverse-branch-1 initial next (cons output list-so-far))))))

(defun reverse-entry-list (rib)
  (let ((init (next-entry rib)))
    (reverse-entry-1 init
		     init
		     'wrap-around)))

(defun reverse-entry-1 (initial current list-so-far)
  (let ((next (next-entry current))
	(output (list (entry-expression current) (entry-environment current))))
    (cond ((eq initial next)
	   (if (entry-mark current)
	       (cons output nil)
	       (cons output list-so-far)))
	  ((entry-mark current)
	   (reverse-entry-1 initial next (cons output nil)))
	  (t
	   (reverse-entry-1 initial next (cons output list-so-far))))))


(defun extract-backbone (current start)
  (if (history-mark current)
      (let ((rev-entry (reverse-entry-list (history-entry current)))
	    (rev-branch (reverse-branch-list (history-branch current))))
	(if (eq (shallower-history current) start)
	    (cons (list rev-entry rev-branch) 'wrap-around)
	    (cons (list rev-entry rev-branch)
		  (extract-backbone (shallower-history current)
				    start))))
      nil))